Shareware Grab Bag/Shareware Grab Bag.iso/007/white.arc/MVPDOSV3.4TH

Text File | 1986-11-07 | 18KB | 546 lines

\ <PAGEW> clear video utility                         13Dec83RSW
        FORTH DEFINITIONS DECIMAL

( <PAGEW> -- SETS 80 COLUMN B&W MODE FOR COLOR GRAPHICS ADPTR )

: <PAGEW>  2 0 0 0 16 INTCALL DROP ;

   FIND <PAGEW> 'PAGE !         ( update init video vector )
   FREEZE

: BEEP  7 EMIT ;  \ alert operator utility





\ MYSELF ASCII BEEP                                   17Dec83RSW
            FORTH DEFINITIONS DECIMAL

: MYSELF  LATEST PFA CFA , ; IMMEDIATE \ recurse do current word

: ASCII  BL WORD 1+ C@ STATE @  \ convert next char to ASCII
   IF [COMPILE] LITERAL
   THEN ;  IMMEDIATE

: BEEP   7 EMIT ;






\                                                     17Dec83RSW
        EXIT














\ .B CARRAY ARRAY STRING                              17Dec83RSW
            FORTH DEFINITIONS DECIMAL

: .B BASE @ DUP ." Now in base " DECIMAL . CR BASE ! ;

: CARRAY ( # bytes --- )  ( # --- addr )
         CREATE 1+ ALLOT DOES> + ;

: ARRAY  ( # words --- )  ( # --- addr )
         CREATE 1+ 2* ALLOT DOES> SWAP 2* + ;

: STRING  ( N-MAX --> )
   CREATE 1 MAX 255 MIN
    DUP C, 0 C, ALLOT
   DOES> 1+ COUNT ;

\ FLEN  return length of a string                     06Nov83RSW
        DECIMAL

: FLEN ( addr --- count ) \  return length of string
 255 0
 DO
   DUP I +
   C@ 0=
   IF
     I LEAVE
   THEN
 LOOP
 SWAP DROP ;



\ ACCEPT LEN MLEN S! string manipulation stuff        13Dec83RSW
        FORTH DEFINITIONS DECIMAL
: ACCEPT  ( string --- ) \ transfer chars from term to string
   DROP 1- DUP 1- @ OVER 1+ DUP ROT ( addr-1 addr addr n --- )
   EXPECT
   FLEN
   SWAP C! ;

: LEN   SWAP DROP ; ( string --- string-current-length )
: MLEN  DROP 2- C@ ; ( string --- string-max-length )

: S!  ( string1 string2 --- ) \ stores string1 into string2
   DROP DUP 2- C@
   ROT MIN DUP 3 PICK 1- C! CMOVE ;


\ <"> " ILINE NULL$      string manipulation stuff    06Nov83RSW

: <">
    R@ COUNT DUP 1+ R> + >R ;
        HEX
: "
   22   \ push terminator " onto stack
   STATE @ IF
        COMPILE <"> WORD C@ 1+ ALLOT
   ELSE
        TEXT PAD COUNT
   THEN ;  IMMEDIATE   DECIMAL


82 STRING ILINE
0 STRING NULL$
\ MID$ RIGHT$ LEFT$ VAL CHR$ ASC SUB!                 06Nov83RSW
        DECIMAL
: MID$
    >R OVER MIN 1 MAX 1-
    SWAP OVER - R> MIN >R + R> ;
: RIGHT$
    OVER 1+ SWAP - 255 MID$ ;
: LEFT$
    1 SWAP MID$ ;
: VAL
    >R PAD 1+ R@ CMOVE R@ PAD C!
    0 PAD 1+ R> + C!
    PAD NUMBER ;
: CHR$  PAD ! PAD 1 ;
: ASC  DROP C@ ;
: SUB!  ROT MIN 0 MAX CMOVE ;
\ S= compare two strings for equality                 06Nov83RSW

: S=
   ROT OVER = IF
     ?DUP IF
       1 SWAP 0 DO
         DROP OVER C@ OVER C@ = IF
           1+ SWAP 1+ SWAP 1
         ELSE 0 LEAVE
         THEN
       LOOP
     ELSE 1
     THEN
   ELSE DROP 0
   THEN
   SWAP DROP SWAP DROP ;
\ S< compare two strings for alphabetic order         13Dec83RSW

: S<    ( str1 str2 --- f ) \ true if str1 lower than str2
   ROT OVER MIN SWAP OVER > >R ?DUP IF
     -1 SWAP 0 DO
       DROP OVER C@ OVER C@ = IF
         1+ SWAP 1+ SWAP -1
       ELSE C@ SWAP C@ > LEAVE
       THEN
     LOOP DUP 0< IF
       2DROP DROP R>
     ELSE R> DROP
     THEN
   ELSE 2DROP R>
   THEN ;

\ S+ STR$ STRING-ARRAY                                06Nov83RSW

: S+
   >R OVER R@ + OVER 2- C@ MIN OVER OVER
   SWAP 1- C! R> 1+ 255 MID$ SUB! ;

: STR$
   SWAP OVER DABS
   <# #S ROT SIGN #> ;

: STRING-ARRAY
   CREATE 0 DO
       DUP C, 0 C, DUP ALLOT
     LOOP
   DOES>
     DUP C@ 2+ ROT * + 1+ COUNT ;
: IN$ ( str1 str2 --- npos ) \ finds position of str1 13Dec83RSW
   DUP 4 PICK - DUP 0> IF
     SWAP OVER - IF
       0 SWAP 2+ 1 DO
         DROP 3 PICK C@ OVER C@ = IF
           3 PICK 3 PICK 3 PICK OVER S= IF
             I LEAVE
           ELSE 1+ 0
           THEN
         ELSE 1+ 0
         THEN
       LOOP
     ELSE DROP 0
     THEN >R 2DROP DROP R>
   ELSE DROP S=
   THEN ;
\ GET$ INPUT$ GET INPUT operator input of data        13Dec83RSW
        HEX
: GET$  ( n-width --- str ) \ fetch kybd chars into string
    PAD                     \ string length limit set by n-width
    1+ DUP ROT EXPECT FLEN PAD C! PAD COUNT ;

: INPUT$  ( --- str )   \ fetch up 80 char string from kybd
    50 GET$ ;

: GET ( n-width --- dn )  \ fetch double number from kybd
    GET$ VAL ;            \ inpu field width set by n-width

: INPUT ( --- dn )      \ fetch double number from kybd
    50 GET ;
                DECIMAL

\ RECLEN FCBLEN DBUFSIZE FCB - DOS file interface     16Nov83RSW
        FORTH DEFINITIONS DECIMAL

128 CONSTANT RECLEN     \ DOS disk file record length

37 CONSTANT FCBLEN      \ DOS file control block length

RECLEN FCBLEN + CONSTANT DBUFSIZE  \ total FCB&data buffer size

: FCB  ( usage "FCB fcb-name" ) \ builds file control block
   CREATE
        HERE  DBUFSIZE ERASE  DBUFSIZE ALLOT
   DOES> ;



\ DSKADR@ SETDMA FILEOP FILEOP2 - DOS file interface  15Nov83RSW
: DSKADR@  ( fcb-addr -- disk-data-addr )
   FCBLEN + ;       \ fetch address of corresponding data buffer

: SETDMA   ( fcb-addr -- )   \ set up disk file transfer address
   26 SWAP  ( function-code fcb-addr -- )
   DSKADR@  ( function-code disk-data-addr -- )
   SYSCALL DROP ; \ do DOS function & drop status

: FILEOP  ( fcb-addr dos-function-code -- DOS-file-status )
   SWAP SYSCALL 255 AND ;  ( normally 0 for no error )
: FILEOP2  FILEOP DUP 0= IF \ do file operation - error?
     DROP DSKADR@           \  no - return start of data address
   ELSE
     SWAP DROP              \  yes - return error code
   THEN ;
\ CLOSEF SEARCHF NEXTF KILLF READF WRITEF - DOS file  16Nov83RSW
: OPENF  ( fcb-addr -- status )  \ open an existing file
    DUP 15 FILEOP             \ do DOS file open
    SWAP 14 + RECLEN SWAP ! ; \ set record length into fcb
: CLOSEF    16 FILEOP ; \ close file after writing
: SEARCHF   17 FILEOP ; \ search directory for a file
: NEXTF     18 FILEOP ; \ search directory for next file
: KILLF     19 FILEOP ; \ wipe out mention of a file

: READF  ( fcb-addr -- data-addr/error) \ read next file record
    DUP DUP SETDMA       \ set up data transfer address
    20 FILEOP2 ;         \ read next record.  4 < is an error

: WRITEF ( fcb-addr -- data-addr/error) \ write next file record
    DUP DUP SETDMA       \ set up data transfer address
    21 FILEOP2 ;         \ write next record   3 < is an error
\ CREATEF RENAMEF FILEOP3 READFR WRITEFR - DOS file   14Nov83RSW
: CREATEF ( fcb-addr -- status) \ create a new flie
    DUP 22 FILEOP               \ do DOS file creation
    SWAP 14 + RECLEN SWAP ! ;   \ set record length into fcb
: RENAMEF      ( fcb-addr -- status ) \ rename a file
    23 FILEOP ; ( NOTE: new name at fcb-addr+17 )

: FILEOP3  OVER 33 + !  DUP DUP SETDMA ;

: READFR  ( fcb-addr record-number -- data-addr/error )
    FILEOP3             \ prepare for random file operation
    33 FILEOP2 ;        \ read a record randomly

: WRITEFR  ( fcb-addr record-number -- data-addr/error )
    FILEOP3             \ prepare for random file operation
    34 FILEOP2 ;        \ write a record randomly
\ DO-TYPE  last part of PREP-FCB - DOS file interface 15Nov83RSW

: DO-TYPE
    DUP C@ ASCII . = IF         \ file type specified?
      SWAP 8 + SWAP 1+          \  yes - fetch it
      3 0 DO
        DUP C@ DUP ASCII ! < IF \ end of file type?
          DROP LEAVE            \  yes - move on
        ELSE
          3 PICK I + C! 1+      \  no - move type char into fcb
        THEN
      LOOP
    THEN
    DROP 5 +  ( fcb-addr+14 -- )
    RECLEN SWAP ! ;             \ set up record length & exit

\ PREP-FCB   DOS file interface cont                  15Nov83RSW
: PREP-FCB   ( fcb-addr filename-addr -- )
    OVER DUP FCBLEN ERASE 1+ 11 BLANK \ null&blank out fcb&buff
    DUP 1+ C@ ASCII : = IF            \ drive specifier?
      DUP C@ ASCII @ -                \  yes - fetch as binary #
      1 MAX 2 MIN 3 PICK C! 2+        \ store only valid range
    THEN         ( fcb-addr filename-addr -- )
    SWAP 1+ SWAP
    8 0 DO                            \ move name char into fcb
      DUP C@ DUP ( fcb-addr+1 filename-addr char char -- )
      ASCII . = OVER ASCII ! < OR IF  \ name field terminator?
        DROP LEAVE                    \  yes - move on
      ELSE
        3 PICK I + C! 1+              \  no - store name char
      THEN
    LOOP   DO-TYPE ;
\ FCTRLZ  truncates string at any control-Z            7Nov83RSW
        FORTH DEFINITIONS DECIMAL
1 STRING EOF  26 CHR$ EOF S!    \ define end-of-file string char

: FCTRLZ         ( addr1 len1 --- )
   EOF           ( addr1 len1 addr2 len2 --- )
   4 PICK 4 ROLL ( addr1 addr2 len2 addr1 len1 --- )
   IN$           ( addr1 npos --- )
   ?DUP 0> IF    ( addr1 ?npos --- )    \ any EOF's?
     1- SWAP 1-  ( npos-1 addr1-1 --- )
     C!                                 \  yes - truncate length
   ELSE
     DROP
   THEN ;


\ FILE1 SEE1  test DOS disk file interface            16Nov83RSW
        FORTH DEFINITIONS DECIMAL
FCB FILE1
RECLEN STRING OBUF
: SEE1          \ define & display FILE1
    FILE1 CR ." file to display? " INPUT$ DROP PREP-FCB
    CR FILE1 OPENF 255 = IF
      ." can't open file " ABORT
    THEN
    BEGIN
      FILE1 READF DUP 3 >
    WHILE
      RECLEN OBUF S! OBUF FCTRLZ OBUF TYPE  \ process file data
    REPEAT
    DROP FILE1 CLOSEF 255 = IF CR ." close error"
      THEN QUIT ;
\ screens to DOS file variables & constants           15Nov83RSW
        FORTH DEFINITIONS DECIMAL
VARIABLE DSKPOS         \ char position in disk buffer
VARIABLE FEND           \ end of DOS file flag
VARIABLE CHARPOS        \ char position in line buffer
2 STRING CRLF 13 CHR$ CRLF S! 10 CHR$ CRLF S+ \ CR LF string
1 STRING TAB 9 CHR$ TAB S!      \ TAB string
8 CONSTANT TABMOD       \ TAB modulus
VARIABLE SCRLIM         \ screen limit storage
VARIABLE LINE-COMPRESS  \ line compression flag
VARIABLE TAB-COMPRESS   \ tab compression flag
VARIABLE SCRLINE        \ screen line #
16 CONSTANT LINE-SCR    \ lines per screen
9 STRING SCR-SEP        \ screen seperator string
NULL$ SCR-SEP S!        \ initialize screen seperator string
VARIABLE BLKADR         \ current block address pointer storage
\ PUTLINE puts line into disk buff-scrns to DOS cont. 16Nov83RSW

: PUTLINE
   ILINE LEN 0> IF                        \ any char in string?
     0 CHARPOS ! BEGIN                    \  yes - doit
       ILINE DROP CHARPOS @ + C@          \ fetch char from line
       FILE1 DSKADR@ DSKPOS @ + C!        \ store char to dskbuf
       1 DSKPOS +! DSKPOS @ RECLEN = IF   \ incr dskpos - full?
         FILE1 WRITEF 3 < IF              \  yes-write disk buf
           CR BEEP ABORT" disk full" THEN \    write error exit
         0 DSKPOS !                       \ reset disk char pos
       THEN
       1 CHARPOS +!                       \ bump string char pos
       CHARPOS @ ILINE LEN =  \ loop until char pos = string len
     UNTIL
   THEN ;
\ COMPRESS spaces out of line buff-scrns to DOS cont.  8Nov83RSW

: COMPRESS
        LINE-COMPRESS @ 0> IF   \ compression turned on ?
          ILINE -TRAILING SWAP 1- C! \ yes - delete trail spaces
          CRLF ILINE S+         \ add carriage-return linefeed
          TAB-COMPRESS @ 0> IF  \ compress spaces to tabs?
            1 DROP              \  yes - add tab compress here
          THEN
        THEN ;






\ WRITE-OPEN    screens to DOS continued              15Nov83RSW

        \ warning - the filename string must end with a null !

: WRITE-OPEN           ( filename-str --- )
   DROP DUP FILE1 SWAP ( filename-addr fcb filename-addr --- )
   PREP-FCB            ( filename-addr --- )    \ prepare fcb
   FILE1 KILLF DROP                \ kill any previous file
   FILE1 SWAP PREP-FCB     ( --- ) \ re-prepare fcb
   FILE1 CREATEF 255 = IF          \ open file - error ?
     BEEP CR ABORT" can't make new file " \ yes - give up
   THEN
   0 DSKPOS !           \ intialize disk buffer offset pointer
   ;


\ FETCH-SCR FETCH-LINE screens to DOS continued        8Nov83RSW

: FETCH-SCR        \ fetches screen # stored in SCR into a BLOCK
   SCR @ BLOCK           ( blk-addr --- )
   BLKADR !              \ intialize block address storage
   SCR-SEP ILINE S!      \ put screen seperator into line buffer
   PUTLINE               \ write screen seperator to disk file
   0 SCRLINE !           \ intialize screen line counter
   1 SCR +! ;            \ update scr # to next screen

: FETCH-LINE      \ fetches line out of a block into line buffer
   BLKADR @ C/L ILINE S!  \ fetch line into line buffer
   C/L BLKADR +!          \ update buffer address to next line
   1 SCRLINE +! ;         \ update line # to next line


: SCRNS->DOS ( first-scr last-scr filename-str ---) \ 17Dec83RSW
   WRITE-OPEN  SCRLIM !  SCR ! CR     \ set up file & scr stuff
   BEGIN SCR @ . 13 EMIT FETCH-SCR    \ get next scr into block
     BEGIN  FETCH-LINE                \ get next line from block
       COMPRESS                       \ do any line compression
       PUTLINE                        \ write line to DOS file
       SCRLINE @ LINE-SCR =           \  till all scr lines done
     UNTIL
     SCR @ SCRLIM @ >                 \  till all scrns done
   UNTIL
   EOF ILINE S!  PUTLINE              \ put ^Z into DOS file
   FILE1 WRITEF 3 < IF                \ write last part of file
     BEEP CR ABORT" disk full" THEN
   FILE1 CLOSEF 255 = IF              \ update DOS directory
     BEEP CR ABORT" close error" THEN
   CR ." screen(s) transfered OK " CR ;
\ SEND-SCRNS transfers standard screens to DOS file    8Nov83RSW

15 STRING OFILE$

: SEND-SCRNS
   CR ." enter 1 to compress lines "
     INPUT DROP LINE-COMPRESS !
   CR ." enter 1 to compress spaces with tabs "
     INPUT DROP TAB-COMPRESS !
   CR ." first screen # ? " INPUT DROP
   CR ." last screen # ? " INPUT DROP
   CR ." desired DOS screen filename ? " INPUT$
   OFILE$ S!
   OFILE$ SCRNS->DOS ;


\ PROC-CHAR process char into line buffer             19Nov83RSW
VARIABLE MAXCHAR  0 MAXCHAR !
: PROC-CHAR                ( char --- )
     DUP 13 = IF                        \ carriage return?
       DROP MAXCHAR @ IF 0 MAXCHAR ! ELSE \ yes-skip if line ful
         C/L CHARPOS @ -                   \ # blanks to write
         ILINE DROP CHARPOS @ + SWAP BLANK \ write blanks
         C/L CHARPOS ! THEN                \ max char counter
     ELSE DUP 10 = IF DROP              \ linefeed? yes - skip
       ELSE DUP 26 = IF                 \ end-of-file?
           1 FEND ! DROP 13 MYSELF \ yes-set end & recurse a CR
         ELSE                      \ no-store char & bump count
           ILINE DROP CHARPOS @ + C!   1 CHARPOS +!
           C/L CHARPOS @ = IF      \ at max char?
             1 MAXCHAR ! THEN      \  yes - set flag
     THEN THEN THEN ;
\ GETLINE gets a screen line from DOS file buffer     16Nov83RSW
: GETLINE
   0 CHARPOS !                      \ initialize line char count
   BEGIN
     FILE1 DSKADR@ DSKPOS @ + C@        \ fetch file char
     PROC-CHAR                          \ put char in line buff
     1 DSKPOS +!                        \ bump disk buff pos
     DSKPOS @ RECLEN = IF               \ finished disk buffer?
       FILE1 READF 4 < IF               \  yes-read more - done
         1 FEND !                       \    yes - set done flag
         13 PROC-CHAR                   \         finish up line
       THEN
       0 DSKPOS !                       \ reset disk buff pos
     THEN
     CHARPOS @ C/L = FEND @ OR          \ till line or file done
   UNTIL   C/L ILINE DROP 1- C! ;       \ set line length
\ READ-OPEN    DOS to screens continued               19Nov83RSW
        \ warning - the filename string must end with a null !
: READ-OPEN            ( filename-str --- )
   DROP FILE1 SWAP     ( fcb filename-addr --- )
   PREP-FCB            ( --- )       \ prepare fcb
   FILE1 OPENF 255 = IF              \ open file - error ?
     BEEP CR ABORT" can't open file" \   yes - give up
   THEN
   FILE1 READF 4 < IF   \ get first record - none?
     BEEP CR ABORT" null length file "     \   yes - give up
   THEN
   0 DSKPOS !           \ intialize disk buffer offset pointer
   0 MAXCHAR ! ;        \ intialize filled line flag



\ LINEPUT  NEXT-SCR    DOS to screens cont.           13Nov83RSW

: LINEPUT               ( --- )
    ILINE DROP BLKADR @ C/L CMOVE \ put line buff in block buff
    C/L BLKADR +!         \ update current block addr
    ;

: NEXT-SCR
    SCR @ BLOCK  ( blk-addr --- ) \ fetch next block
    DUP BLKADR !                  \ intialize block address
    UPDATE                        \ mark as modified
    LINE-SCR C/L * BLANK          \ blank out block
    1 SCR +!                      \ point to next screen
    ;


\ DOS->SCRNS  DOS file to FORTH screens transfer      11Nov83RSW

: DOS->SCRNS ( first-scr filename-str --- ) \
  READ-OPEN SCR !  0 FEND ! \ open DOS file & set variables
  BEGIN  NEXT-SCR       \ fetch next screen blk
    LINE-SCR 0 DO       \ write appropiate # lines into scre
      GETLINE           \ fetch line out of file buffer
      LINEPUT           \ put line into block buffer
      FEND @ IF         \ found DOS file end?
        LEAVE           \  yes - exit now
      THEN
    LOOP
    FEND @              \  till DOS file end
  UNTIL
  FLUSH CR ." finished. Last screen was "
  SCR @ 1 - DUP SCR ! . CR ;
\ GET-SCRNS transfers DOS file to standard screens    10Nov83RSW

: GET-SCRNS
   CR ." first screen # ? " INPUT DROP
   CR ." desired DOS screen filename ? " INPUT$
   OFILE$ S!
   OFILE$ DOS->SCRNS ;









een # ? " INPUT DROP
   CR ."